#!/usr/bin/perl
#
# enko2ck.pl
# check 'enko' file format validation
# 
#  'enko' file format is quick&dirty-ly designed by amorette,
# which stands for 'english-korean'. this will not completely
# works. but it will help you concentrating on what-you-do.
#
# bug report: amorettia@gmail.com
#
# ChangeLog:
#   2009-03-12  0.00     created by amorette
#   2009-03-12  0.02     written anew.
#   2009-03-12  0.03     quickly argument option supported.
# 
use warnings;
use strict;
use Term::ANSIColor qw(:constants);
$Term::ANSIColor::AUTORESET = 1;

our $VERSION = '0.03';

sub error;
sub warning;
sub check;
sub ldump;

my %opts = ();      # options
my %checked = ();  # check list
my %warned = ();   # warning list
my @sect = ();     # segments are recorded here.

my $optf = 0;
my $rx_linest = qr{^%%(.*)\:(\d+)=+$};
my $rx_linemd = qr{^%%-+$}; 
my $rx_lineed = qr{^%%=+$};

# orz....
for (grep { /^-(.+)$/ } @ARGV) {
    if    ($_ eq '--no-warning'   ) { $optf |= 1 }
    elsif ($_ eq '--no-check'     ) { $optf |= 2 }
    elsif ($_ eq '--no-error'     ) { $optf |= 4 }
    elsif ($_ eq '--only-warning' ) { $optf  = 6 }
    elsif ($_ eq '--only-check'   ) { $optf  = 5 }
    elsif ($_ eq '--only-error'   ) { $optf  = 3 }
    elsif ($_ eq '--no-ldump'     ) { $optf |= 8 }
    elsif ($_ eq '--version'      ) { p_ver()    }
    else {
	goto usage;
    }
}

my ( $file ) = grep { $_ !~ /^--(.+)$/ } @ARGV;

usage: if (!defined($file)) {
    print "usage: enko2ck.pl [options] <enko_file>\n";
    print "         --only-warning\n";
    print "         --only-check\n";
    print "         --only-error\n";
    print "         --no-warning\n";
    print "         --no-check\n";
    print "         --no-error\n";
    print "         --no-ldump\n";
    print "         --version\n";
    exit(1);
}

sub p_ver {
    print "enko2ck.pl ($VERSION)\n";
    print 'amorettia@gmail.com'."\n";
    exit;
}

print "enko2ck.pl: checking $file\n";
open my $fh, "<", $file or die "File not found";
my @lines = <$fh>;
close $fh;

#
# HERE WE GO  (parsing)
#

my $pdiv = undef;  # previous div
my $csec = undef;  # current section[segment]
my $crev = undef;  # current revision

for my $i ( 0 .. $#lines ) {
    my $l = $lines[$i];

    # get start division
    if ($l =~ $rx_linest) {
	my $psec = $csec;
	($crev, $csec) = ($1, $2);
	if ($csec !~ /^\d+$/) {
	    error $i+1, "Segment is not numerical value. ($csec)", $i;
	}
	if ($sect[$csec][1]) {
	    error $i+1, "Division line is not correct.", $pdiv, $i;
	}
	if ($psec && $psec > $csec) {
	    error $i+1, "Segment order is in reverse.", $sect[$psec][1], $i;
	}
	$sect[$csec] = [$crev, $i];
	$pdiv = $i;
    }

    # get middle division
    elsif ($l =~ $rx_linemd) {
	if (!defined($sect[$csec][1]) || $sect[$csec][2]) {
	    error $i+1, "Division line is not correct.", $pdiv, $i;
	}
	$sect[$csec][2] = $i;
	$pdiv = $i;
    }

    # get end division
    elsif ($l =~ $rx_lineed) {
	if (@{$sect[$csec]}[1..2] ~~ undef || $sect[$csec][3]) {
	    error $i+1, "Division line is not correct.", $pdiv, $i;
	}	
	$sect[$csec][3] = $i;
	$pdiv = $i;
    }
}




my $prv = '';      # previous $rev
my $pst = 0;       # previous $st
my $pmd = undef;   # previous $md
my $ped = undef;   # previous $ed
my $pnm = undef;   # previous $num

for my $num ( 1 .. $#sect ) {
    unless ($sect[$num]) {
	warning('prompt', $pst+1, "Segment number is not sequential (where is the $num segment?)");
	warning('SEGNSQ', $pst+1, "but this is not error as it could be deliberate maintainance.",
		$pst, $sect[(grep{$sect[$_][1]}$num..$#sect)[0]][1]);
	next;
    }

    my ($rev, $st, $md, $ed) = @{ $sect[$num] };

    unless ($st || $md || $ed) {
	warning('prompt', $pst+1, "Segment number is not sequential (where is the $num segment?)");
	warning('SEGNSQ', $pst+1, "but this is not error as it could be deliberate maintainance.",
		$pst, $sect[(grep{$sect[$_][1]}$num..$#sect)[0]][1]);
	next;
    }
    
    # revision changed (not equal)
    if ($rev ne $prv) {
	warning('prompt', $pst+1, "Revision number/string is not equal ('$prv' and '$rev')");
	warning('REVNEQ', $pst+1, "but this is not error as it could be deliberate maintainance.",
		$pst, $st);
    }

    # source seg is too largen
    if ($md - $st > 4) {
	my @is_dot = grep { $_ !~ /^\.\\\"/ && (m/\.[\s\)]|\.^/ || m/^\s+$/) } @lines[$st+1..$md-1];
	defined($is_dot[1]) and 
	    warning('SEGBIG', $st+1, "Source segment seems large  ".
		"(please divide them more if you can)", $st, $md);
    }
    
    # source seg is empty
    if ($st + 1 == $md) {
	# trans seg is also empty?
	if ($md + 1 == $ed) {
	    warning('prompt', $st+1, "Doubtful. Empty Segment. (this is really needed?)");
	    warning('REVNEQ', $st+1,
		    "but this is not error as it could be deliberate maintainance.", $st);
	}
	# error, this is called 'insertion'
	elsif ($rev ne 'ins') {
	    error($st+1, "Insertion is not good.  ".
		  "(if you really need, make revision name as 'ins')", $st);
	}
	# when you explicitly use, just warn.
	else {
	    warning('INSERT', $st+1, "Insertion is used.  (this habit is not good)", $st);
	}
    }
    
    elsif ($md + 1 == $ed) {
	check('prompt', $md, "Not translated at all. (let's fill in!)");
	unless ($checked{DSCEMP}) {
	    check('DSCEMP', $md, "when the content to be translated is quitely same as source,\n".
		  "or to retain as is, don't insert any line and keep empty like this.", $md, $ed);
	}
    }
    else {
	my @not_empty = grep { $lines[$_] !~ /^(\.\\\")?\s*$/ } $md+1..$ed-1;
	unless ($not_empty[0]) {
	    error($md+1, "Only empty characters are in the Segment.\n".
		  "(or attach these lines to adjacent segments?)", $md+1);
	}
    }
    
    
    ($pnm, $prv) = ($num, $rev);
    ($pst, $pmd, $ped) = ($st, $md, $ed);
}


sub error ($$;$$$;$$$$) {
    return if $optf & 4;
    my ( $where, $what, $start, $end) = @_;
    print BOLD, RED, "error: $where: $what", RESET, "\n";
    if (defined($start) && defined($end)) {
	ldump ($start, $end);
    }
    elsif (defined($start)) {
	ldump ($start, $start);
    }
    exit(1);
}

sub check ($$$;$$$$;$$$$$) {
    return if $optf & 2;
    my ( $c, $where, $what, $start, $end ) = @_;
    print GREEN, "check: $where: $what", RESET, "\n";
    unless ($checked{$c} && $c ne 'prompt') {
	if (defined($start) && defined($end)) {
	    ldump ($start, $end);
	}
	elsif (defined($start)) {
	    ldump ($start, $start);
	}
    }
    $checked{$c}++;
}

sub warning ($$$;$$$$;$$$$$){
    return if $optf & 1;
    my ( $w, $where, $what, $start, $end ) = @_;
    print BOLD, MAGENTA, "warning: $where: $what", RESET, "\n";
    unless ($warned{$w} && $w ne 'prompt') {
	if (defined($start) && defined($end)) {
	    ldump ($start, $end);
	}
	elsif (defined($start)) {
	    ldump ($start, $start);
	}
    }
    $warned{$w}++;
}

sub ldump {
    return if $optf & 8;
    my (%view, @view, $max);
    my ($one, $two) = @_;
    map { $view{$_}++ } ($one-2..$one+3, $two-3..$two+2);
    map { $view{$_+4} && (map {$view{$_}++} $_..$_+4)} keys %view;
    @view = sort {$a<=>$b} grep {$_>=0 && $_<=$#lines} keys %view;
    $max = length($view[-1]);

    for (@view) {
	my $lno = " "x($max-length).($_+1);
	if ($_ == $one || $_ == $two) {
	    print BOLD, YELLOW, "<$lno>: $lines[$_]", RESET;
	}
	else {
	    print "<$lno>: $lines[$_]";
	}
	unless ($view{$_+1}) {
	    print "<@{['.'x$max]}>: ...\n";
	}
    }
    print "\n";
}
